home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
CD ROM Paradise Collection 4
/
CD ROM Paradise Collection 4 1995 Nov.iso
/
program
/
4cmp22s.zip
/
STRINGS2.4TH
< prev
next >
Wrap
Text File
|
1994-10-30
|
3KB
|
98 lines
\ STRING SUPPORT LIBRARY PART 2
\ Contents Copyright (C) 1986 by Thomas Almy
\ Permission is granted to registered users of ForthCMP to sell or distribute
\ computer programs incorporating the compiled contents of this file.
\ Load this before FORTHLIB
.( Loading STRINGS ) CR
10 DECIMAL DSEG
U: STRXTR >R DUP >R - 0 MAX SWAP R> + SWAP R> MIN ;
U: STRCPY OVER C@ 1+ CMOVE ;
U: ASCIIZ COUNT DUP >R 1+ +STRBUF
STRBUF R@ CMOVE 0 STRBUF R> + C! STRBUF ;
U: -ASCIIZ DUP 255 0 SCAN DROP OVER - DUP 1+ +STRBUF
DUP STRBUF C! STRBUF 1+ SWAP CMOVE STRBUF ;
U: -EXT 2DUP -PATH
[CHAR] . SCAN 0= IF DROP ELSE NIP OVER - THEN ;
U: +EXT OVER COUNT -PATH
[CHAR] . SCAN 0<> IF 2DROP EXIT THEN
DROP SWAP COUNT ROT COUNT STRCAT STRPCK ;
U: -PATH BEGIN 2DUP [CHAR] \ SCAN DUP WHILE
2SWAP 2DROP [CHAR] \ SKIP REPEAT 2DROP ;
U: SEARCH 2>R 2DUP BEGIN DUP R@ >= WHILE OVER R@ 2R@ COMPARE
0= IF 2R> 2DROP 2SWAP 2DROP 1 EXIT THEN 1 /STRING REPEAT
2R> 2DROP 2DROP 0 ;
U: COMPARE >R >R ?DS: -ROT ?DS: R> R> STRCMPL ;
U: COMPAREL
>R ROT R@ OVER >R MIN cmpl ?DUP IF R> DROP R> DROP EXIT THEN
R> R> 2DUP > IF 2DROP 1 EXIT THEN
< ;
SEPDSEG? [IF]
: argc 1 129 128 CS: C@ STR>DSEG
BEGIN BL SKIP DUP WHILE BL SCAN ROT 1+ -ROT REPEAT 2DROP ;
[ELSE]
: argc 1 128 COUNT BEGIN BL SKIP DUP WHILE BL SCAN ROT 1+ -ROT REPEAT 2DROP ;
[THEN]
?DEFINE argv [IF]
VARIABLE argvM 1 argvM ! \ constant value
SEPDSEG? [IF]
: argv DUP 1 < IF DROP 44 CS: @ DUP 0 1024 ?DS: argvM 2 STRNDXL
DUP 0< IF 2DROP 0 0 STRPCK EXIT THEN
CELL+ -ASCIIZL EXIT THEN
129 128 CS: C@ STR>DSEG
BL SKIP ROT 1- 0 ?DO BL SCAN BL SKIP LOOP
2DUP BL SCAN DROP NIP OVER - STRPCK ;
[ELSE]
: argv DUP 1 < IF DROP 44 @ DUP 0 1024 ?DS: argvM 2 STRNDXL
DUP 0< IF 2DROP 0 0 STRPCK EXIT THEN
CELL+ -ASCIIZL EXIT THEN
128 COUNT BL SKIP ROT 1- 0 ?DO BL SCAN BL SKIP LOOP
2DUP BL SCAN DROP NIP OVER - STRPCK ;
[THEN] [THEN]
U: getenv
S" =" STR>DSEG STRCAT 2>R
44 CS: @ 0 BEGIN 2DUP C@L WHILE
2DUP ?DS: 2R@ cmpl 0= IF 2R> NIP + -ASCIIZL EXIT THEN
BEGIN 1+ 2DUP C@L 0= UNTIL 1+ REPEAT
2R> 2DROP 2DROP 0 0 STRPCK ;
U: STRCAT DUP 3 PICK + DUP >R +STRBUF
2 PICK STRBUF + SWAP CMOVE
STRBUF SWAP CMOVE STRBUF R> ;
U: STRPCK DUP >R 1+ +STRBUF STRBUF 1+ R@ CMOVE R> STRBUF C! STRBUF ;
U: -ASCIIZL
2DUP BEGIN 2DUP C@L WHILE 1+ REPEAT
NIP OVER - DUP >R 1+ +STRBUF
?DS: STRBUF 1+ R@ CMOVEL R> STRBUF C! STRBUF ;
SEPDSEG? [IF]
U: STR>DSEG
DUP >R +STRBUF ?CS: SWAP ?DS: STRBUF R@ CMOVEL STRBUF R> ; [ELSE]
U: STR>DSEG ( DUMMY ) ;
[THEN]
U: +STRBUF DUP strend + strbufr StringSize + U> IF
strbufr + TO strend strbufr TO STRBUF
ELSE
strend DUP TO STRBUF + TO strend THEN ;
?DEFINE STRNDX ?DEFINE STRNDXL OR [IF]
VARIABLE strndX 4 ALLOT [THEN]
U: STRNDX TUCK strndX 2!
- DUP 0< IF 2DROP -1 EXIT THEN
-1 -ROT ( save answer )
1+ 0 DO ?DS: OVER ?DS: strndX 2@ cmpl 0= IF DROP I SWAP LEAVE THEN 1+ LOOP
DROP ;
U: STRNDXL
strndX ! strndX CELL+ 2!
strndX @ - DUP 0< IF 2DROP DROP -1 EXIT THEN
>R -1 -ROT R>
1+ 0 DO 2DUP strndX CELL+ 2@ strndX @ cmpl 0= IF DROP I -ROT LEAVE THEN 1+ LOOP
2DROP ;
UNDEF cmpl
CODE cmpl
BX POP DX DS <SEG CX POP DI POP ES POPSEG SI POP DS POPSEG
REPZ BYTE CMPS DX DS >SEG 0 # AX MOV =0 ~ IF, <0 IF,
AX DEC ELSE, AX INC THEN, THEN, AX PUSH BX JMP END-CODE [THEN]
16 = [IF] HEX [THEN]